home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / fr.scm < prev    next >
Text File  |  1995-10-13  |  16KB  |  419 lines
  1. ;;; Field and record parsing utilities for scsh.
  2. ;;; Copyright (c) 1994 by Olin Shivers.
  3.  
  4. ;;; Notes:
  5. ;;; - Comment on the dependencies here...
  6. ;;; - Awk should deal with case-insensitivity.
  7. ;;; - Should I change the field-splitters to return lists? It's the
  8. ;;;   right thing, and costs nothing in terms of efficiency.
  9.  
  10. ;;; Looping primitives:
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ;;; It is nicer for loops that loop over a bunch of different things
  13. ;;; if you can encapsulate the idea of iterating over a data structure
  14. ;;; with a 
  15. ;;;     (next-element state) -> elt next-state
  16. ;;;     (more-elements? state) -? #t/#f
  17. ;;; generator/termination-test pair. You can use the generator with REDUCE
  18. ;;; to make a list; you can stick it into a loop macro to loop over the 
  19. ;;; elements. For example, if we had an extensible Yale-loop style loop macro,
  20. ;;; we could have a loop clause like
  21. ;;; 
  22. ;;;     (loop (for field in-infix-delimited-string ":" path)
  23. ;;;           (do (display field) (newline)))
  24. ;;; 
  25. ;;; and it would be simple to expand this into code using the generator.
  26. ;;; With procedural inlining, you can get pretty optimal loops over data
  27. ;;; structures this way.
  28. ;;;
  29. ;;; As of now, you are forced to parse fields into a buffer, and loop
  30. ;;; over that. This is inefficient of time and space.  If I ever manage to do
  31. ;;; an extensible loop macro for Scheme 48, I'll have to come back to this
  32. ;;; package and rethink how to provide this functionality.
  33.  
  34. ;;; Forward-progress guarantees and empty string matches.
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;; A loop that pulls text off a string by matching a regexp against
  37. ;;; that string can conceivably get stuck in an infinite loop if the
  38. ;;; regexp matches the empty string. For example, the regexps
  39. ;;; ^, $, .*, foo|[^f]* can all match the empty string.
  40. ;;; 
  41. ;;; The regexp-loop routines in this code are careful to handle this case. 
  42. ;;; If a regexp matches the empty string, the next search starts, not from
  43. ;;; the end of the match (which in the empty string case is also the 
  44. ;;; beginning -- there's the rub), but from the next character over.
  45. ;;; This is the correct behaviour. Regexps match the longest possible
  46. ;;; string at a given location, so if the regexp matched the empty string
  47. ;;; at location i, then it is guaranteed they could not have matched
  48. ;;; a longer pattern starting with character #i. So we can safely begin
  49. ;;; our search for the next match at char i+1.
  50. ;;; 
  51. ;;; So every iteration through the loop makes some forward progress,
  52. ;;; and the loop is guaranteed to terminate.
  53. ;;; 
  54. ;;; This has the effect you want with field parsing. For example, if you split
  55. ;;; a string with the empty pattern, you will explode the string into its
  56. ;;; individual characters:
  57. ;;;     ((suffix-splitter "") "foo") -> #("" "f" "o" "o")
  58. ;;; However, even though this boundary case is handled correctly, we don't
  59. ;;; recommend using it. Say what you mean -- just use a field splitter:
  60. ;;;     ((field-splitter ".") "foo") -> #("f" "o" "o")
  61.  
  62.  
  63.  
  64. ;;; (join-strings string-list [delimiter grammar]) => string
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66. ;;; Paste strings together using the delimiter string.
  67. ;;;
  68. ;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
  69. ;;;
  70. ;;; DELIMITER defaults to a single space " "
  71. ;;; GRAMMAR is one of the symbols {infix, suffix} and defaults to 'infix.
  72.  
  73. ;;; (join-strings strings [delim grammar])
  74.  
  75. (define (join-strings strings . args)
  76.   (if (pair? strings)
  77.       (receive (delim grammar) (parse-optionals args " " 'infix)
  78.     (check-arg string? delim join-strings)
  79.     (let ((strings (reverse strings)))
  80.       (let lp ((strings (cdr strings))
  81.            (ans (case grammar
  82.               ((infix)  (list (car strings)))
  83.               ((suffix) (list (car strings) delim))
  84.               (else (error "Illegal grammar" grammar)))))
  85.         (if (pair? strings)
  86.         (lp (cdr strings)
  87.             (cons (car strings) (cons delim ans)))
  88.       
  89.         ; All done
  90.         (apply string-append ans)))))
  91.  
  92.       ""))    ; Special-cased for infix grammar.
  93.  
  94. ;;; FIELD PARSERS
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. ;;; This section defines routines to split a string into fields.
  97. ;;; You can parse by specifying a pattern that *separates* fields,
  98. ;;; a pattern that *terminates* fields, or a pattern that *matches*
  99. ;;; fields.
  100.  
  101. (define (->delim-matcher x)
  102.   (if (procedure? x) x                    ; matcher proc
  103.       (let ((re (cond ((regexp? x) x)            ; regexp pattern
  104.               ((string? x) (make-regexp x))    ; regexp string
  105.               (else (error "Illegal pattern/parser" x)))))
  106.  
  107.     ;; The matcher proc.
  108.     (lambda (s i)
  109.       (cond ((regexp-exec re s i) =>
  110.          (lambda (m) (values (match:start m 0) (match:end m 0))))
  111.         (else (values #f #f)))))))
  112.  
  113. ;;; (infix-splitter         [re num-fields handle-delim])    -> parser
  114. ;;; (suffix-splitter        [re num-fields handle-delim])    -> parser
  115. ;;; (sloppy-suffix-splitter [re num-fields handle-delim])    -> parser
  116. ;;; (field-splitter         [re num-fields])              -> parser
  117. ;;;
  118. ;;; (parser string [start]) -> string-list
  119.  
  120. (define (make-field-parser-generator default-delim-matcher loop-proc)
  121.   ;; This is the parser-generator
  122.   (lambda args
  123.     (receive (delim-spec num-fields handle-delim)
  124.          (parse-optionals args  default-delim-matcher #f 'trim)
  125.  
  126.       ;; Process and error-check the args
  127.       (let ((match-delim (->delim-matcher delim-spec))
  128.         (cons-field (case handle-delim         ; Field     is s[i,j).
  129.               ((trim)            ; Delimiter is s[j,k).
  130.                (lambda (s i j k fields)
  131.                  (cons (substring s i j) fields)))
  132.               ((split)
  133.                (lambda (s i j k fields)
  134.                  (cons (substring s j k)
  135.                    (cons (substring s i j) fields))))
  136.               ((concat)
  137.                (lambda (s i j k fields)
  138.                  (cons (substring s i k)
  139.                    fields)))
  140.               (else
  141.                (error "Illegal handle-delim spec"
  142.                   handle-delim)))))
  143.  
  144.     (receive (num-fields nfields-exact?)
  145.              (cond ((not num-fields) (values #f #f))
  146.                ((not (integer? num-fields))
  147.             (error "Illegal NUM-FIELDS value" num-fields))
  148.                ((<= num-fields 0) (values (- num-fields) #f))
  149.                (else (values num-fields #t)))
  150.  
  151.       ;; This is the parser.
  152.       (lambda (s . maybe-start)
  153.         (reverse (loop-proc s (optional-arg maybe-start 0)
  154.                 match-delim cons-field
  155.                 num-fields nfields-exact?))))))))
  156.  
  157. (define default-field-matcher (->delim-matcher "[^ \t\n]+"))
  158.  
  159. ;;; (field-splitter [field-spec num-fields])
  160.  
  161. (define (field-splitter . args)
  162.   (receive (field-spec num-fields)
  163.        (parse-optionals args  default-field-matcher #f)
  164.  
  165.     ;; Process and error-check the args
  166.     (let ((match-field (->delim-matcher field-spec)))
  167.       (receive (num-fields nfields-exact?)
  168.            (cond ((not num-fields) (values #f #f))
  169.              ((not (integer? num-fields))
  170.               (error "Illegal NUM-FIELDS value"
  171.                  field-splitter num-fields))
  172.              ((<= num-fields 0) (values (- num-fields) #f))
  173.              (else (values num-fields #t)))
  174.  
  175.     ;; This is the parser procedure.
  176.     (lambda (s . maybe-start)
  177.       (reverse (fieldspec-field-loop s (optional-arg maybe-start 0)
  178.                      match-field num-fields nfields-exact?)))))))
  179.  
  180.  
  181. ;;; These four procedures implement the guts of each parser
  182. ;;; (field, infix, suffix, and sloppy-suffix).
  183. ;;;
  184. ;;; The CONS-FIELD argument is a procedure that parameterises the
  185. ;;; HANDLE-DELIM action for the field parser.
  186. ;;; 
  187. ;;; The MATCH-DELIM argument is used to match a delimiter. 
  188. ;;; (MATCH-DELIM S I) returns two integers [start, end] marking
  189. ;;; the next delimiter after index I in string S. If no delimiter is
  190. ;;; found, it returns [#f #f].
  191.  
  192. ;;; In the main loop of each parser, the loop variable LAST-NULL? tells if the
  193. ;;; previous delimiter-match matched the empty string. If it did, we start our
  194. ;;; next delimiter search one character to the right of the match, so we won't
  195. ;;; loop forever. This means that an empty delimiter regexp "" simply splits
  196. ;;; the string at each character, which is the correct thing to do.
  197. ;;;
  198. ;;; These routines return the answer as a reversed list.
  199.  
  200.  
  201. (define (fieldspec-field-loop s start match-field num-fields nfields-exact?)
  202.   (let ((end (string-length s)))
  203.     (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
  204.       (let ((j (if last-null? (+ i 1) i)) ; Where to start next delim search.
  205.  
  206.         ;; Check to see if we made our quota before returning answer.
  207.         (finish-up (lambda ()
  208.              (if (and num-fields (< nfields num-fields))
  209.                  (error "Too few fields in record." num-fields s)
  210.                  fields))))
  211.  
  212.     (cond ((> j end) (finish-up))    ; We are done. Finish up.
  213.  
  214.           ;; Read too many fields. Bomb out.
  215.           ((and nfields-exact? (> nfields num-fields))
  216.            (error "Too many fields in record." num-fields s))
  217.  
  218.           ;; Made our lower-bound quota. Quit early.
  219.           ((and num-fields (= nfields num-fields) (not nfields-exact?))
  220.            (if (= i end) fields    ; Special case hackery.
  221.            (cons (substring s i end) fields)))
  222.  
  223.           ;; Match off another field & loop.
  224.           (else (receive (m0 m1) (match-field s j)
  225.                   (if m0 (lp m1 (+ nfields 1)
  226.                  (cons (substring s m0 m1) fields)
  227.                  (=  m0 m1))
  228.               (finish-up)))))))))    ; No more matches. Finish up.
  229.  
  230.  
  231. (define (infix-field-loop s start match-delim cons-field
  232.               num-fields nfields-exact?)
  233.   (let ((end (string-length s)))
  234.     (if (= start end) '() ; Specially hack empty string.
  235.  
  236.     (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
  237.       (let ((finish-up (lambda ()
  238.                  ;; s[i,end) is the last field. Terminate the loop.
  239.                  (cond ((and num-fields (< (+ nfields 1) num-fields))
  240.                     (error "Too few fields in record."
  241.                        num-fields s))
  242.                   
  243.                    ((and nfields-exact?
  244.                      (>= nfields num-fields))
  245.                     (error "Too many fields in record."
  246.                        num-fields s))
  247.  
  248.                    (else
  249.                     (cons (substring s i end) fields)))))
  250.  
  251.         (j (if last-null? (+ i 1) i))) ; Where to start next search.
  252.  
  253.         (cond
  254.           ;; If we've read NUM-FIELDS fields, quit early .
  255.               ((and num-fields (= nfields num-fields))
  256.            (if nfields-exact?
  257.                (error "Too many fields in record." num-fields s)
  258.                (cons (substring s i end) fields)))
  259.  
  260.         
  261.           ((<= j end)        ; Match off another field.
  262.            (receive (m0 m1) (match-delim s j)
  263.              (if m0
  264.              (lp m1 (+ nfields 1)
  265.                  (cons-field s i m0 m1 fields)
  266.                  (= m0 m1))
  267.              (finish-up)))) ; No more delimiters - finish up.
  268.  
  269.           ;; We've run off the end of the string. This is a weird
  270.           ;; boundary case occuring with empty-string delimiters.
  271.           (else (finish-up))))))))
  272.  
  273.  
  274.  
  275. ;;; Match off an optional initial delimiter,
  276. ;;; then jump off to the suffix parser.
  277.  
  278. (define (sloppy-suffix-field-loop s start match-delim cons-field
  279.                   num-fields nfields-exact?)
  280.   ;; If sloppy-suffix, skip an initial delimiter if it's there.
  281.   (let ((start (receive (i j) (match-delim s start)
  282.                  (if (and i (zero? i)) j start))))
  283.     (suffix-field-loop s start match-delim cons-field
  284.                num-fields nfields-exact?)))
  285.  
  286.  
  287. (define (suffix-field-loop s start match-delim cons-field
  288.                num-fields nfields-exact?)
  289.   (let ((end (string-length s)))
  290.  
  291.     (let lp ((i start) (nfields 0) (fields '()) (last-null? #f))
  292.       (let ((j (if last-null? (+ i 1) i))) ; Where to start next delim search.
  293.     (cond ((= i end) ; We are done.
  294.            (if (and num-fields (< nfields num-fields)) ; Didn't make quota.
  295.            (error "Too few fields in record." num-fields s)
  296.            fields))
  297.  
  298.           ;; Read too many fields. Bomb out.
  299.           ((and nfields-exact? (= nfields num-fields))
  300.            (error "Too many fields in record." num-fields s))
  301.  
  302.               ;; Made our lower-bound quota. Quit early.
  303.           ((and num-fields (= nfields num-fields) (not nfields-exact?))
  304.            (cons (substring s i end) fields))
  305.  
  306.           (else ; Match off another field.
  307.            (receive (m0 m1) (match-delim s j)
  308.          (if m0 (lp m1 (+ nfields 1)
  309.                 (cons-field s i m0 m1 fields)
  310.                 (= m0 m1))
  311.              (error "Missing field terminator" s)))))))))
  312.  
  313.  
  314. ;;; Now, build the exported procedures: {infix,suffix,sloppy-suffix}-splitter.
  315.  
  316. (define default-suffix-matcher (->delim-matcher "[ \t\n]+|$"))
  317. (define default-infix-matcher  (->delim-matcher "[ \t\n]+"))
  318.  
  319. (define infix-splitter
  320.   (make-field-parser-generator default-infix-matcher  infix-field-loop))
  321. (define suffix-splitter
  322.   (make-field-parser-generator default-suffix-matcher suffix-field-loop))
  323. (define sloppy-suffix-splitter
  324.   (make-field-parser-generator default-suffix-matcher sloppy-suffix-field-loop))
  325.  
  326.  
  327.  
  328. ;;; Reading records
  329. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  330.  
  331. (define default-record-delims (char-set #\newline))
  332.  
  333. ;;; (record-reader [delims elide? handle-delim]) -> reader
  334. ;;; (reader [port]) -> string or eof
  335.  
  336. (define (record-reader . args)
  337.   (receive (delims elide? handle-delim)
  338.            (parse-optionals args default-record-delims #f 'trim)
  339.     (let ((delims (->char-set delims)))
  340.  
  341.       (case handle-delim
  342.     ((trim)            ; TRIM-delimiter reader.
  343.      (lambda maybe-port
  344.        (let ((s (apply read-delimited delims maybe-port)))
  345.          (if (not (eof-object? s))
  346.          (if elide?
  347.              (apply skip-char-set delims maybe-port) ; Snarf delims.
  348.              (apply read-char maybe-port))) ; Just snarf one.
  349.          s)))
  350.  
  351.     ((concat split)        ; CONCAT-delimiter & SPLIT-delimiter reader.
  352.      (let ((not-delims (char-set-invert delims)))
  353.        (lambda maybe-port
  354.          (let ((s (apply read-delimited delims maybe-port)))
  355.            (if (eof-object? s) s
  356.            (let ((delim (if elide?
  357.                     (apply read-delimited not-delims maybe-port)
  358.                     (string (apply read-char maybe-port)))))
  359.              (if (eq? handle-delim 'split)
  360.              (values s delim)
  361.              (if (eof-object? delim) s
  362.                  (string-append s delim)))))))))
  363.  
  364.     (else
  365.      (error "Illegal delimiter-action" handle-delim))))))
  366.  
  367.  
  368. ;;; Reading and parsing records
  369. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  370. ;;; (field-reader [field-parser rec-reader]) -> reader
  371. ;;; (reader [port]) -> [raw-record parsed-record] or [eof #()]
  372. ;;; 
  373. ;;; This is the field reader, which is basically just a composition of
  374. ;;; RECORD-READER and FIELD-PARSER.
  375.  
  376. (define default-field-parser (field-splitter))
  377.  
  378. (define (field-reader . args)
  379.   (receive (parser rec-reader)
  380.            (parse-optionals args default-field-parser read-line)
  381.     (lambda maybe-port
  382.       (let ((record (apply rec-reader maybe-port)))
  383.     (if (eof-object? record)
  384.         (values record '#())
  385.         (values record (parser record)))))))
  386.  
  387.  
  388.  
  389. ;;; Parse fields by regexp
  390. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  391. ;;; This code parses up a record into fields by matching a regexp specifying
  392. ;;; the field against the record. The regexp describes the *field*. In the
  393. ;;; other routines, the regexp describes the *delimiters*. They are
  394. ;;; complimentary.
  395.  
  396. ;;; Repeatedly do (APPLY PROC M STATE) to generate new state values,
  397. ;;; where M is a regexp match structure made from matching against STRING.
  398.  
  399. ;(define (regexp-reduce string start regexp proc . state)
  400. ;  (let ((end (string-length string))
  401. ;    (regexp (if (string? regexp)
  402. ;            (make-regexp regexp)
  403. ;            regexp)))
  404. ;
  405. ;    (let lp ((i start) (state state) (last-null? #f))
  406. ;      (let ((j (if last-null? (+ i 1) i)))
  407. ;    (cond ((and (<= j end) (regexp-exec regexp string j)) =>
  408. ;               (lambda (m)
  409. ;         (receive state (apply proc m state)
  410. ;           (lp (match:end m) state (= (match:start m) (match:end m))))))
  411. ;          (else (apply values state)))))))
  412. ;
  413. ;(define (all-regexp-matches regexp string)
  414. ;  (reverse (regexp-reduce string 0 regexp
  415. ;              (lambda (m ans) (cons (match:substring m 0) ans))
  416. ;              '())))
  417.  
  418.  
  419.